1 time tk from youtube & github

1.1 options & settings

chunk options

CSS for scrollable output & Header colors

Turning scientific / Exponential numbers off

options(scipen = 999)

1.3 Loading libs

library(tidyverse)
library(ggthemes)
library(timetk)
library(lubridate)

1.4 Creating & setting custom theme


theme_viny_bright <- function(){
  
  library(ggthemes)
  
  ggthemes::theme_fivethirtyeight() %+replace%
  
  theme(
    axis.title = element_text(),
    
    axis.text = element_text(size = 13),
    
    legend.text = element_text(size = 10),
    
    panel.background = element_rect(fill = "white"),
    
    plot.background = element_rect(fill = "white"),
    
    strip.background = element_blank(),
    
    legend.background = element_rect(fill = NA),
    
    legend.key = element_rect(fill = NA),

    plot.title = element_text(hjust = 0.5,
                              size = 19,
                              face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, colour = "maroon")
      )
  
  }

theme_set(theme_viny_bright())

1.5 Loading data

bike_sharing_daily <- read.csv("../timetk_1st_try/day.csv")
head(bike_sharing_daily)
bike_sharing_daily %>% str()
'data.frame':   731 obs. of  16 variables:
 $ instant   : int  1 2 3 4 5 6 7 8 9 10 ...
 $ dteday    : chr  "2011-01-01" "2011-01-02" "2011-01-03" "2011-01-04" ...
 $ season    : int  1 1 1 1 1 1 1 1 1 1 ...
 $ yr        : int  0 0 0 0 0 0 0 0 0 0 ...
 $ mnth      : int  1 1 1 1 1 1 1 1 1 1 ...
 $ holiday   : int  0 0 0 0 0 0 0 0 0 0 ...
 $ weekday   : int  6 0 1 2 3 4 5 6 0 1 ...
 $ workingday: int  0 0 1 1 1 1 1 0 0 1 ...
 $ weathersit: int  2 2 1 1 1 1 2 2 1 1 ...
 $ temp      : num  0.344 0.363 0.196 0.2 0.227 ...
 $ atemp     : num  0.364 0.354 0.189 0.212 0.229 ...
 $ hum       : num  0.806 0.696 0.437 0.59 0.437 ...
 $ windspeed : num  0.16 0.249 0.248 0.16 0.187 ...
 $ casual    : int  331 131 120 108 82 88 148 68 54 41 ...
 $ registered: int  654 670 1229 1454 1518 1518 1362 891 768 1280 ...
 $ cnt       : int  985 801 1349 1562 1600 1606 1510 959 822 1321 ...
walmart_sales_weekly %>% str()
tibble [1,001 x 17] (S3: tbl_df/tbl/data.frame)
 $ id          : Factor w/ 3331 levels "1_1","1_2","1_3",..: 1 1 1 1 1 1 1 1 1 1 ...
 $ Store       : num [1:1001] 1 1 1 1 1 1 1 1 1 1 ...
 $ Dept        : num [1:1001] 1 1 1 1 1 1 1 1 1 1 ...
 $ Date        : Date[1:1001], format: "2010-02-05" "2010-02-12" ...
 $ Weekly_Sales: num [1:1001] 24925 46039 41596 19404 21828 ...
 $ IsHoliday   : logi [1:1001] FALSE TRUE FALSE FALSE FALSE FALSE ...
 $ Type        : chr [1:1001] "A" "A" "A" "A" ...
 $ Size        : num [1:1001] 151315 151315 151315 151315 151315 ...
 $ Temperature : num [1:1001] 42.3 38.5 39.9 46.6 46.5 ...
 $ Fuel_Price  : num [1:1001] 2.57 2.55 2.51 2.56 2.62 ...
 $ MarkDown1   : num [1:1001] NA NA NA NA NA NA NA NA NA NA ...
 $ MarkDown2   : num [1:1001] NA NA NA NA NA NA NA NA NA NA ...
 $ MarkDown3   : num [1:1001] NA NA NA NA NA NA NA NA NA NA ...
 $ MarkDown4   : num [1:1001] NA NA NA NA NA NA NA NA NA NA ...
 $ MarkDown5   : num [1:1001] NA NA NA NA NA NA NA NA NA NA ...
 $ CPI         : num [1:1001] 211 211 211 211 211 ...
 $ Unemployment: num [1:1001] 8.11 8.11 8.11 8.11 8.11 ...

1.6 plot time series

bike_sharing_daily %>% 
  plot_time_series(dteday, cnt)
Error: Problem with `mutate()` input `.value_smooth`.
x No method for class character.
i Input `.value_smooth` is `auto_smooth(...)`.
Run `rlang::last_error()` to see where the error occurred.
bike_sharing_daily <- bike_sharing_daily %>% 
  mutate(dteday = as.Date(dteday)) 

bike_sharing_daily %>% 
  str()
'data.frame':   731 obs. of  16 variables:
 $ instant   : int  1 2 3 4 5 6 7 8 9 10 ...
 $ dteday    : Date, format: "2011-01-01" "2011-01-02" ...
 $ season    : int  1 1 1 1 1 1 1 1 1 1 ...
 $ yr        : int  0 0 0 0 0 0 0 0 0 0 ...
 $ mnth      : int  1 1 1 1 1 1 1 1 1 1 ...
 $ holiday   : int  0 0 0 0 0 0 0 0 0 0 ...
 $ weekday   : int  6 0 1 2 3 4 5 6 0 1 ...
 $ workingday: int  0 0 1 1 1 1 1 0 0 1 ...
 $ weathersit: int  2 2 1 1 1 1 2 2 1 1 ...
 $ temp      : num  0.344 0.363 0.196 0.2 0.227 ...
 $ atemp     : num  0.364 0.354 0.189 0.212 0.229 ...
 $ hum       : num  0.806 0.696 0.437 0.59 0.437 ...
 $ windspeed : num  0.16 0.249 0.248 0.16 0.187 ...
 $ casual    : int  331 131 120 108 82 88 148 68 54 41 ...
 $ registered: int  654 670 1229 1454 1518 1518 1362 891 768 1280 ...
 $ cnt       : int  985 801 1349 1562 1600 1606 1510 959 822 1321 ...
bike_sharing_daily %>% 
  plot_time_series(dteday, cnt)

NA
bike_sharing_daily %>% 
  plot_time_series(dteday, 
                   cnt,
                   .color_var = lubridate::quarter(dteday, with_year = TRUE)
                   )
bike_sharing_daily %>% 
  plot_time_series(dteday, 
                   cnt,
                   .color_var = lubridate::month(dteday)#, with_year = TRUE)
                   )
bike_sharing_daily %>% 
  plot_time_series(dteday, 
                   cnt,
                   .color_var = lubridate::semester(dteday, with_year = TRUE)
                   )

1.6.1 log transformation

bike_sharing_daily %>% 
  plot_time_series(dteday,
                   log(cnt),
                   .color_var = quarter(dteday, with_year = TRUE)
                   )

1.6.2 Anomaly Series

bike_sharing_daily %>% 
  plot_anomaly_diagnostics(dteday,
                           cnt)

In video log(cnt) was used for anomaly detection

bike_sharing_daily %>% 
  plot_anomaly_diagnostics(dteday,
                           log(cnt)
                           )
walmart_sales_weekly %>% summarise_all(n_distinct)
walmart_sales_weekly %>% 
  group_by(id) %>% 
  plot_time_series(Date,
                   Weekly_Sales,
                   .facet_ncol = 2)
walmart_sales_weekly %>% 
  group_by(id) %>% 
  plot_time_series(Date,
                   log(Weekly_Sales),
                   .facet_ncol = 2)
walmart_sales_weekly %>% 
  group_by(id) %>% 
  plot_anomaly_diagnostics(Date,
                           Weekly_Sales,
                           .facet_ncol = 2)

1.6.3 seasonal diagnostics

bike_sharing_daily %>% 
  plot_seasonal_diagnostics(dteday,
                            cnt)
bike_sharing_daily %>% 
  plot_seasonal_diagnostics(dteday,
                            cnt)

first 2 groups

walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1:2) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales)
bike_sharing_daily %>% 
  plot_seasonal_diagnostics(dteday,
                            cnt,
                            .feature_set = "wday.lbl")
bike_sharing_daily %>% 
  plot_seasonal_diagnostics(dteday,
                            cnt,
                            .feature_set = "wday.lbl",
                            .geom = c("violin")
  )
walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1:2) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales,
                            .feature_set = "wday.lbl")
walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales,
                            .feature_set = "week")
walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1:2) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales,
                            .feature_set = "week")
walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1:2) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales,
                            .feature_set = "month.lbl")
walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1:2) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales,
                            .feature_set = "hour")
walmart_sales_weekly %>% 
  group_by(id) %>% 
  filter(group_indices() %in% 1) %>% 
  plot_seasonal_diagnostics(Date,
                            Weekly_Sales,
                            .feature_set = "hour")
bike_sharing_daily %>% 
  plot_seasonal_diagnostics(dteday,
                            cnt,
                            .feature_set = "hour")

Looks like we don’t have hour wise data in our data frame


1.7 Time Signature

library(workflows)
library(parsnip)
library(tidyquant)
bikes_tbl <- bike_sharing_daily %>% 
  select(dteday, cnt) %>% 
  rename(date = dteday,
         value = cnt)

str(bikes_tbl)
'data.frame':   731 obs. of  2 variables:
 $ date : Date, format: "2011-01-01" "2011-01-02" ...
 $ value: int  985 801 1349 1562 1600 1606 1510 959 822 1321 ...

understanding splitting of data visually

bikes_tbl %>% 
  ggplot(aes(x = date, y = value)) +
  geom_rect(xmin = as.numeric(ymd("2012-07-01")),
            xmax = as.numeric(ymd("2013-01-01")),
            ymin = 0, ymax = 10000,
            fill = palette_light()[[4]], alpha = 0.01
            ) +
  annotate("text", x = ymd("2011-10-01"), y = 7800,
           color = palette_light()[[1]], label = "Train Region") +
  annotate("text", x = ymd("2012-10-01"), y = 1550,
           color = palette_light()[[1]], label = "Test Region") +
  geom_point(alpha = 0.5, color = palette_light()[[1]]) +
  labs(title = "Bikes sharing dataset") +
  theme_tq()

1.7.1 train test split

train_tbl <- bikes_tbl %>% filter(date < ymd("2012-07-01"))
test_tbl <- bikes_tbl %>% filter(date >= ymd("2012-07-01"))
dim(train_tbl)
[1] 547   2
dim(test_tbl)
[1] 184   2

1.7.2 Recipe

recipe_spec_ts <- recipe(value ~ .,
                         data = train_tbl) %>% 
                  step_timeseries_signature(date)

recipe_spec_ts
Data Recipe

Inputs:

Operations:

Timeseries signature features from date
baked <- bake(prep(recipe_spec_ts), new_data = train_tbl)

head(baked)
str(baked)
tibble [547 x 29] (S3: tbl_df/tbl/data.frame)
 $ date          : Date[1:547], format: "2011-01-01" "2011-01-02" ...
 $ value         : int [1:547] 985 801 1349 1562 1600 1606 1510 959 822 1321 ...
 $ date_index.num: int [1:547] 1293840000 1293926400 1294012800 1294099200 1294185600 1294272000 1294358400 1294444800 1294531200 1294617600 ...
 $ date_year     : int [1:547] 2011 2011 2011 2011 2011 2011 2011 2011 2011 2011 ...
 $ date_year.iso : int [1:547] 2010 2010 2011 2011 2011 2011 2011 2011 2011 2011 ...
 $ date_half     : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_quarter  : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_month    : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_month.xts: int [1:547] 0 0 0 0 0 0 0 0 0 0 ...
 $ date_month.lbl: Ord.factor w/ 12 levels "January"<"February"<..: 1 1 1 1 1 1 1 1 1 1 ...
 $ date_day      : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_hour     : int [1:547] 0 0 0 0 0 0 0 0 0 0 ...
 $ date_minute   : int [1:547] 0 0 0 0 0 0 0 0 0 0 ...
 $ date_second   : int [1:547] 0 0 0 0 0 0 0 0 0 0 ...
 $ date_hour12   : int [1:547] 0 0 0 0 0 0 0 0 0 0 ...
 $ date_am.pm    : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_wday     : int [1:547] 7 1 2 3 4 5 6 7 1 2 ...
 $ date_wday.xts : int [1:547] 6 0 1 2 3 4 5 6 0 1 ...
 $ date_wday.lbl : Ord.factor w/ 7 levels "Sunday"<"Monday"<..: 7 1 2 3 4 5 6 7 1 2 ...
 $ date_mday     : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_qday     : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_yday     : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_mweek    : int [1:547] 1 2 2 2 2 2 2 2 3 3 ...
 $ date_week     : int [1:547] 1 1 1 1 1 1 1 2 2 2 ...
 $ date_week.iso : int [1:547] 52 52 1 1 1 1 1 1 1 2 ...
 $ date_week2    : int [1:547] 1 1 1 1 1 1 1 0 0 0 ...
 $ date_week3    : int [1:547] 1 1 1 1 1 1 1 2 2 2 ...
 $ date_week4    : int [1:547] 1 1 1 1 1 1 1 2 2 2 ...
 $ date_mday7    : int [1:547] 1 1 1 1 1 1 2 2 2 2 ...
recipe_spec_final <- recipe_spec_ts %>% 
                      #step_rm(date)  # keeping this commented as it creates problem in use some algorithm
                      step_rm(contains("iso"), 
                              contains("minute"),
                              contains("hour"),
                              contains("am.pm"),
                              contains("xts")
                              ) %>% 
                      step_normalize(contains("index.num"), date_year) %>% 
                      step_dummy(contains("lbl"), one_hot = TRUE)

recipe_spec_final
Data Recipe

Inputs:

Operations:

Timeseries signature features from date
Delete terms contains("iso"), contains("minute"), ...
Centering and scaling for contains("index.num"), date_year
Dummy variables from contains("lbl")
baked_final <- bake(prep(recipe_spec_final), new_data = train_tbl)

baked_final %>% head()
str(baked_final)
tibble [547 x 38] (S3: tbl_df/tbl/data.frame)
 $ date             : Date[1:547], format: "2011-01-01" "2011-01-02" ...
 $ value            : int [1:547] 985 801 1349 1562 1600 1606 1510 959 822 1321 ...
 $ date_index.num   : num [1:547] -1.73 -1.72 -1.71 -1.71 -1.7 ...
 $ date_year        : num [1:547] -0.705 -0.705 -0.705 -0.705 -0.705 ...
 $ date_half        : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_quarter     : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_month       : int [1:547] 1 1 1 1 1 1 1 1 1 1 ...
 $ date_day         : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_second      : int [1:547] 0 0 0 0 0 0 0 0 0 0 ...
 $ date_wday        : int [1:547] 7 1 2 3 4 5 6 7 1 2 ...
 $ date_mday        : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_qday        : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_yday        : int [1:547] 1 2 3 4 5 6 7 8 9 10 ...
 $ date_mweek       : int [1:547] 1 2 2 2 2 2 2 2 3 3 ...
 $ date_week        : int [1:547] 1 1 1 1 1 1 1 2 2 2 ...
 $ date_week2       : int [1:547] 1 1 1 1 1 1 1 0 0 0 ...
 $ date_week3       : int [1:547] 1 1 1 1 1 1 1 2 2 2 ...
 $ date_week4       : int [1:547] 1 1 1 1 1 1 1 2 2 2 ...
 $ date_mday7       : int [1:547] 1 1 1 1 1 1 2 2 2 2 ...
 $ date_month.lbl_01: num [1:547] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_02: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_03: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_04: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_05: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_06: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_07: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_08: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_09: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_10: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_11: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_month.lbl_12: num [1:547] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:12] 1 1 1 1 1 1 1 1 1 1 ...
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_month.lbl: chr "contr.poly"
 $ date_wday.lbl_1  : num [1:547] 0 1 0 0 0 0 0 0 1 0 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"
 $ date_wday.lbl_2  : num [1:547] 0 0 1 0 0 0 0 0 0 1 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"
 $ date_wday.lbl_3  : num [1:547] 0 0 0 1 0 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"
 $ date_wday.lbl_4  : num [1:547] 0 0 0 0 1 0 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"
 $ date_wday.lbl_5  : num [1:547] 0 0 0 0 0 1 0 0 0 0 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"
 $ date_wday.lbl_6  : num [1:547] 0 0 0 0 0 0 1 0 0 0 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"
 $ date_wday.lbl_7  : num [1:547] 1 0 0 0 0 0 0 1 0 0 ...
  ..- attr(*, "assign")= int [1:7] 1 1 1 1 1 1 1
  ..- attr(*, "contrasts")=List of 1
  .. ..$ date_wday.lbl: chr "contr.poly"

1.7.3 Model Specs

model_spec_glmnet <- linear_reg(mode = "regression") %>% 
                      set_engine("lm")

1.7.4 Workflow

workflow_glmnet <- workflow() %>% 
                    add_recipe(recipe_spec_final) %>% 
                    add_model(model_spec_glmnet)

workflow_glmnet
== Workflow ==========================================================================
Preprocessor: Recipe
Model: linear_reg()

-- Preprocessor ----------------------------------------------------------------------
4 Recipe Steps

* step_timeseries_signature()
* step_rm()
* step_normalize()
* step_dummy()

-- Model -----------------------------------------------------------------------------
Linear Regression Model Specification (regression)

Computational engine: lm 

1.7.5 Training / fitting

workflow_trained_glmnet <- workflow_glmnet %>% 
                      fit(data = train_tbl)

workflow_trained_glmnet
== Workflow [trained] ================================================================
Preprocessor: Recipe
Model: linear_reg()

-- Preprocessor ----------------------------------------------------------------------
4 Recipe Steps

* step_timeseries_signature()
* step_rm()
* step_normalize()
* step_dummy()

-- Model -----------------------------------------------------------------------------

Call:
stats::lm(formula = ..y ~ ., data = data)

Coefficients:
      (Intercept)               date     date_index.num          date_year  
     -7532592.347            495.618                 NA         -84513.676  
        date_half       date_quarter         date_month           date_day  
        -1871.725         108808.572         -50395.422          -1579.073  
      date_second          date_wday          date_mday          date_qday  
               NA             22.248                 NA           1200.819  
        date_yday         date_mweek          date_week         date_week2  
               NA           -432.567           -227.352             59.342  
       date_week3         date_week4         date_mday7  date_month.lbl_01  
           23.963             -2.619           -143.249          -3401.120  
date_month.lbl_02  date_month.lbl_03  date_month.lbl_04  date_month.lbl_05  
        -4153.950           -110.377           -661.662            596.505  
date_month.lbl_06  date_month.lbl_07  date_month.lbl_08  date_month.lbl_09  
               NA           2756.234           1166.565                 NA  
date_month.lbl_10  date_month.lbl_11  date_month.lbl_12    date_wday.lbl_1  
         2015.666                 NA                 NA            338.453  
  date_wday.lbl_2    date_wday.lbl_3    date_wday.lbl_4    date_wday.lbl_5  
          226.378            292.336             15.391            108.059  
  date_wday.lbl_6    date_wday.lbl_7  
               NA                 NA  

1.7.6 Test / Validation

prediction_glmnet_tbl <- workflow_trained_glmnet %>% 
  predict(test_tbl) %>% 
  bind_cols(test_tbl)

prediction_glmnet_tbl
bikes_tbl %>% 
  ggplot(aes(x = date, y = value)) +
  geom_rect(xmin = as.numeric(ymd("2012-07-01")),
            xmax = as.numeric(ymd("2013-01-01")),
            ymin = 0, ymax = 10000,
            fill = palette_light()[[4]], alpha = 0.01
            ) +
  annotate("text", x = ymd("2011-10-01"), y = 7800,
           color = palette_light()[[1]], label = "Train Region") +
  annotate("text", x = ymd("2012-10-01"), y = 1550,
           color = palette_light()[[1]], label = "Test Region") +
  geom_point(aes(x = date, y = value),
             alpha = 0.5, color = palette_light()[[1]]) +
  
  #Add predictions
  geom_point(aes(x = date, y = .pred), data = prediction_glmnet_tbl,
             alpha = 0.5, color = palette_light()[[2]]) +
  
  labs(title = "Bikes sharing dataset with predictions") +
  theme_tq()

1.7.7 Validation Accuracy

prediction_glmnet_tbl %>% 
  metrics(value, .pred)
prediction_glmnet_tbl %>% 
  ggplot(aes(x = date, y = value - .pred)) +
  geom_hline(yintercept = 0, color = "red") +
  geom_point(color = palette_light()[[1]], alpha = 0.5) +
  geom_smooth() +
  theme_tq() +
  labs(title = "GLM Model residuals on test set") +
  scale_y_continuous(limits = c(-5000, 5000))

NA

1.7.8 Forecast

head(idx)
[1] "2011-01-01" "2011-01-02" "2011-01-03" "2011-01-04" "2011-01-05" "2011-01-06"
idx_future <- idx %>% tk_make_future_timeseries(length_out = 200)

head(idx_future)
[1] "2013-01-01" "2013-01-02" "2013-01-03" "2013-01-04" "2013-01-05" "2013-01-06"
future_tbl <- tibble(date = idx_future)

future_tbl
future_predictions_tbl <- workflow_trained_glmnet %>% 
  fit(data = bikes_tbl) %>% 
  predict(future_tbl) %>% 
  bind_cols(future_tbl)

head(future_predictions_tbl)
bikes_tbl %>% 
  ggplot(aes(x = date, y = value)) +
  geom_rect(xmin = as.numeric(ymd("2012-07-01")),
            xmax = as.numeric(ymd("2013-01-01")),
            ymin = 0, ymax = 10000,
            fill = palette_light()[[4]], alpha = 0.01
            ) +
  geom_rect(xmin = as.numeric(ymd("2013-01-01")),
            xmax = as.numeric(ymd("2013-07-01")),
            ymin = 0, ymax = 10000,
            fill = palette_light()[[5]], alpha = 0.01
            ) +
  annotate("text", x = ymd("2011-10-01"), y = 7800,
           color = palette_light()[[1]], label = "Train Region") +
  annotate("text", x = ymd("2012-10-01"), y = 1550,
           color = palette_light()[[1]], label = "Test Region") +
  annotate("text", x = ymd("2013-04-01"), y = 1550,
           color = palette_light()[[1]], label = "Forecast Region") +
  geom_point(#aes(x = date, y = value),
             alpha = 0.5, color = palette_light()[[1]]) +
  
  #Add predictions
  geom_point(aes(x = date, y = .pred), data = prediction_glmnet_tbl,
             alpha = 0.5, color = palette_light()[[2]]) +
  geom_point(aes(x = date, y = .pred), data = future_predictions_tbl,
             alpha = 0.5, color = palette_light()[[2]]) +
  
  geom_smooth(aes(x = date, y = .pred), data = future_predictions_tbl,
              method = "loess") +
  
  labs(title = "Bikes sharing dataset with predictions") +
  theme_tq()

1.7.9 Forecast Error

future_predictions_tbl <- future_predictions_tbl %>% 
  mutate(lo.95 = .pred - 1.96 * test_resid_sd$stdev,
         lo.80 = .pred - 1.28 * test_resid_sd$stdev,
         hi.80 = .pred + 1.28 * test_resid_sd$stdev,
         hi.95 = .pred + 1.96 * test_resid_sd$stdev
         )

head(future_predictions_tbl)
bikes_tbl %>% 
  ggplot(aes(x = date, y = value)) +
  geom_point(alpha = 0.5, color = palette_light()[[1]]) +
  geom_ribbon(aes(y = .pred, ymin = lo.95, ymax = hi.95), 
              data = future_predictions_tbl,
              fill = "#050BFF", color = NA, size = 0) +
  geom_ribbon(aes(y = .pred, ymin = lo.80, ymax = hi.80, fill = key), 
              data = future_predictions_tbl,
              fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
  geom_point(aes(x = date, y = .pred), data = future_predictions_tbl,
             alpha = 0.5, color = palette_light()[[2]]) +
  geom_smooth(aes(x = date, y = .pred), data = future_predictions_tbl,
              method = "loess", color = "white") +
  labs(title = "Bikes Shaing Dataset") +
  theme_tq()

LS0tDQp0aXRsZTogInRpbWV0ayAybmQiDQpvdXRwdXQ6IA0KICBodG1sX25vdGVib29rOg0KICAgIGhpZ2hsaWdodDogdGFuZ28NCiAgICBkZl9wcmludDogcGFnZWQNCiAgICB0b2M6IHRydWUNCiAgICB0b2NfZmxvYXQ6IA0KICAgICAgY29sbGFwc2VkOiB0cnVlDQogICAgICBzbW9vdGhfc2Nyb2xsOiBmYWxzZQ0KICAgIG51bWJlcl9zZWN0aW9uczogdHJ1ZQ0KICAgIHRvY19kZXB0aDogNg0KLS0tDQoNCg0KIyB0aW1lIHRrIGZyb20geW91dHViZSAmIGdpdGh1Yg0KDQojIyBvcHRpb25zICYgc2V0dGluZ3MNCg0KDQpjaHVuayBvcHRpb25zDQoNCmBgYHtyIHNldHVwLCBpbmNsdWRlPUZBTFNFfQ0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGVjaG8gPSBUUlVFLCBtZXNzYWdlID0gRkFMU0UsIHdhcm5pbmcgPSBGQUxTRSwgZHBpID0gMzAwLCBvdXQud2lkdGggPSAiMTAwJSIsYXR0ci5vdXRwdXQ9J3N0eWxlPSJtYXgtaGVpZ2h0OiAzMDBweDsiJykNCmBgYA0KDQoNCkNTUyBmb3Igc2Nyb2xsYWJsZSBvdXRwdXQgJiBIZWFkZXIgY29sb3JzIA0KDQpgYGB7Y3NzLCBlY2hvPUZBTFNFfQ0KLnNjcm9sbC0xMDAgew0KICBtYXgtaGVpZ2h0OiAxMDBweDsNCiAgb3ZlcmZsb3cteTogYXV0bzsNCiAgYmFja2dyb3VuZC1jb2xvcjogaW5oZXJpdDsNCn0NCg0KdGJvZHkgdHI6aG92ZXIgew0KICBiYWNrZ3JvdW5kOiAjZGRkZGRkOw0KfQ0KDQoNCmgxLCAjVE9DPnVsPmxpIHsNCiAgY29sb3I6ICNCNjREM0E7DQp9DQoNCmgyLCAjVE9DPnVsPnVsPmxpIHsNCiAgY29sb3I6ICMwMDAwMDA7DQp9DQoNCmgzLCAjVE9DPnVsPnVsPnVsPmxpIHsNCiAgY29sb3I6ICM2NDNjYjI7DQp9DQoNCmg0LCAjVE9DPnVsPnVsPnVsPnVsPmxpIHsNCiAgY29sb3I6ICNhZTAwNTg7DQp9DQoNCmg1LCAjVE9DPnVsPnVsPnVsPnVsPnVsPmxpIHsNCiAgY29sb3I6ICNmZmE0NDc7DQp9DQoNCmg2LCAjVE9DPnVsPnVsPnVsPnVsPnVsPnVsPmxpIHsNCiAgY29sb3I6ICNEQUUzRDk7DQp9DQoNCmBgYA0KDQpUdXJuaW5nIHNjaWVudGlmaWMgLyBFeHBvbmVudGlhbCBudW1iZXJzIG9mZg0KDQpgYGB7cn0NCm9wdGlvbnMoc2NpcGVuID0gOTk5KQ0KYGBgDQoNCg0KIyMgU291cmNlDQoNCmZyb206IGh0dHBzOi8vd3d3LnlvdXR1YmUuY29tL3dhdGNoP3Y9Q3FVSURVTllQeWsNCg0KDQojIyBMb2FkaW5nIGxpYnMNCg0KYGBge3J9DQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkoZ2d0aGVtZXMpDQpgYGANCg0KDQpgYGB7cn0NCmxpYnJhcnkodGltZXRrKQ0KbGlicmFyeShsdWJyaWRhdGUpDQpgYGANCg0KDQojIyBDcmVhdGluZyAmIHNldHRpbmcgY3VzdG9tIHRoZW1lDQoNCmBgYHtyfQ0KDQp0aGVtZV92aW55X2JyaWdodCA8LSBmdW5jdGlvbigpew0KICANCiAgbGlicmFyeShnZ3RoZW1lcykNCiAgDQogIGdndGhlbWVzOjp0aGVtZV9maXZldGhpcnR5ZWlnaHQoKSAlK3JlcGxhY2UlDQogIA0KICB0aGVtZSgNCiAgICBheGlzLnRpdGxlID0gZWxlbWVudF90ZXh0KCksDQogICAgDQogICAgYXhpcy50ZXh0ID0gZWxlbWVudF90ZXh0KHNpemUgPSAxMyksDQogICAgDQogICAgbGVnZW5kLnRleHQgPSBlbGVtZW50X3RleHQoc2l6ZSA9IDEwKSwNCiAgICANCiAgICBwYW5lbC5iYWNrZ3JvdW5kID0gZWxlbWVudF9yZWN0KGZpbGwgPSAid2hpdGUiKSwNCiAgICANCiAgICBwbG90LmJhY2tncm91bmQgPSBlbGVtZW50X3JlY3QoZmlsbCA9ICJ3aGl0ZSIpLA0KICAgIA0KICAgIHN0cmlwLmJhY2tncm91bmQgPSBlbGVtZW50X2JsYW5rKCksDQogICAgDQogICAgbGVnZW5kLmJhY2tncm91bmQgPSBlbGVtZW50X3JlY3QoZmlsbCA9IE5BKSwNCiAgICANCiAgICBsZWdlbmQua2V5ID0gZWxlbWVudF9yZWN0KGZpbGwgPSBOQSksDQoNCiAgICBwbG90LnRpdGxlID0gZWxlbWVudF90ZXh0KGhqdXN0ID0gMC41LA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgc2l6ZSA9IDE5LA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgZmFjZSA9ICJib2xkIiksDQogICAgcGxvdC5zdWJ0aXRsZSA9IGVsZW1lbnRfdGV4dChoanVzdCA9IDAuNSwgY29sb3VyID0gIm1hcm9vbiIpDQogICAgICApDQogIA0KICB9DQoNCnRoZW1lX3NldCh0aGVtZV92aW55X2JyaWdodCgpKQ0KYGBgDQoNCg0KIyMgTG9hZGluZyBkYXRhDQoNCmBgYHtyfQ0KYmlrZV9zaGFyaW5nX2RhaWx5IDwtIHJlYWQuY3N2KCIuLi90aW1ldGtfMXN0X3RyeS9kYXkuY3N2IikNCmhlYWQoYmlrZV9zaGFyaW5nX2RhaWx5KQ0KYGBgDQoNCg0KYGBge3J9DQpiaWtlX3NoYXJpbmdfZGFpbHkgJT4lIHN0cigpDQpgYGANCg0KYGBge3J9DQp3YWxtYXJ0X3NhbGVzX3dlZWtseSAlPiUgc3RyKCkNCmBgYA0KDQojIyBwbG90IHRpbWUgc2VyaWVzDQoNCmBgYHtyfQ0KYmlrZV9zaGFyaW5nX2RhaWx5ICU+JSANCiAgcGxvdF90aW1lX3NlcmllcyhkdGVkYXksIGNudCkNCmBgYA0KDQpgYGB7cn0NCmJpa2Vfc2hhcmluZ19kYWlseSA8LSBiaWtlX3NoYXJpbmdfZGFpbHkgJT4lIA0KICBtdXRhdGUoZHRlZGF5ID0gYXMuRGF0ZShkdGVkYXkpKSANCg0KYmlrZV9zaGFyaW5nX2RhaWx5ICU+JSANCiAgc3RyKCkNCmBgYA0KDQoNCmBgYHtyfQ0KYmlrZV9zaGFyaW5nX2RhaWx5ICU+JSANCiAgcGxvdF90aW1lX3NlcmllcyhkdGVkYXksIGNudCkNCg0KYGBgDQoNCmBgYHtyfQ0KYmlrZV9zaGFyaW5nX2RhaWx5ICU+JSANCiAgcGxvdF90aW1lX3NlcmllcyhkdGVkYXksIA0KICAgICAgICAgICAgICAgICAgIGNudCwNCiAgICAgICAgICAgICAgICAgICAuY29sb3JfdmFyID0gbHVicmlkYXRlOjpxdWFydGVyKGR0ZWRheSwgd2l0aF95ZWFyID0gVFJVRSkNCiAgICAgICAgICAgICAgICAgICApDQpgYGANCg0KDQpgYGB7cn0NCmJpa2Vfc2hhcmluZ19kYWlseSAlPiUgDQogIHBsb3RfdGltZV9zZXJpZXMoZHRlZGF5LCANCiAgICAgICAgICAgICAgICAgICBjbnQsDQogICAgICAgICAgICAgICAgICAgLmNvbG9yX3ZhciA9IGx1YnJpZGF0ZTo6bW9udGgoZHRlZGF5KSMsIHdpdGhfeWVhciA9IFRSVUUpDQogICAgICAgICAgICAgICAgICAgKQ0KYGBgDQoNCg0KYGBge3J9DQpiaWtlX3NoYXJpbmdfZGFpbHkgJT4lIA0KICBwbG90X3RpbWVfc2VyaWVzKGR0ZWRheSwgDQogICAgICAgICAgICAgICAgICAgY250LA0KICAgICAgICAgICAgICAgICAgIC5jb2xvcl92YXIgPSBsdWJyaWRhdGU6OnNlbWVzdGVyKGR0ZWRheSwgd2l0aF95ZWFyID0gVFJVRSkNCiAgICAgICAgICAgICAgICAgICApDQpgYGANCg0KIyMjIGxvZyB0cmFuc2Zvcm1hdGlvbg0KDQpgYGB7cn0NCmJpa2Vfc2hhcmluZ19kYWlseSAlPiUgDQogIHBsb3RfdGltZV9zZXJpZXMoZHRlZGF5LA0KICAgICAgICAgICAgICAgICAgIGxvZyhjbnQpLA0KICAgICAgICAgICAgICAgICAgIC5jb2xvcl92YXIgPSBxdWFydGVyKGR0ZWRheSwgd2l0aF95ZWFyID0gVFJVRSkNCiAgICAgICAgICAgICAgICAgICApDQpgYGANCg0KIyMjIEFub21hbHkgU2VyaWVzDQoNCmBgYHtyfQ0KYmlrZV9zaGFyaW5nX2RhaWx5ICU+JSANCiAgcGxvdF9hbm9tYWx5X2RpYWdub3N0aWNzKGR0ZWRheSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgIGNudCkNCmBgYA0KDQpJbiB2aWRlbyBsb2coY250KSB3YXMgdXNlZCBmb3IgYW5vbWFseSBkZXRlY3Rpb24NCg0KYGBge3J9DQpiaWtlX3NoYXJpbmdfZGFpbHkgJT4lIA0KICBwbG90X2Fub21hbHlfZGlhZ25vc3RpY3MoZHRlZGF5LA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgbG9nKGNudCkNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICkNCmBgYA0KDQpgYGB7cn0NCndhbG1hcnRfc2FsZXNfd2Vla2x5ICU+JSBzdW1tYXJpc2VfYWxsKG5fZGlzdGluY3QpDQpgYGANCg0KYGBge3J9DQp3YWxtYXJ0X3NhbGVzX3dlZWtseSAlPiUgDQogIGdyb3VwX2J5KGlkKSAlPiUgDQogIHBsb3RfdGltZV9zZXJpZXMoRGF0ZSwNCiAgICAgICAgICAgICAgICAgICBXZWVrbHlfU2FsZXMsDQogICAgICAgICAgICAgICAgICAgLmZhY2V0X25jb2wgPSAyKQ0KYGBgDQoNCmBgYHtyfQ0Kd2FsbWFydF9zYWxlc193ZWVrbHkgJT4lIA0KICBncm91cF9ieShpZCkgJT4lIA0KICBwbG90X3RpbWVfc2VyaWVzKERhdGUsDQogICAgICAgICAgICAgICAgICAgbG9nKFdlZWtseV9TYWxlcyksDQogICAgICAgICAgICAgICAgICAgLmZhY2V0X25jb2wgPSAyKQ0KYGBgDQoNCmBgYHtyfQ0Kd2FsbWFydF9zYWxlc193ZWVrbHkgJT4lIA0KICBncm91cF9ieShpZCkgJT4lIA0KICBwbG90X2Fub21hbHlfZGlhZ25vc3RpY3MoRGF0ZSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgIFdlZWtseV9TYWxlcywNCiAgICAgICAgICAgICAgICAgICAgICAgICAgIC5mYWNldF9uY29sID0gMikNCmBgYA0KDQojIyMgc2Vhc29uYWwgZGlhZ25vc3RpY3MNCg0KYGBge3J9DQpiaWtlX3NoYXJpbmdfZGFpbHkgJT4lIA0KICBwbG90X3NlYXNvbmFsX2RpYWdub3N0aWNzKGR0ZWRheSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICBjbnQpDQpgYGANCg0KDQpgYGB7ciBmaWcuaGVpZ2h0PTEwfQ0KYmlrZV9zaGFyaW5nX2RhaWx5ICU+JSANCiAgcGxvdF9zZWFzb25hbF9kaWFnbm9zdGljcyhkdGVkYXksDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgY250KQ0KYGBgDQoNCmZpcnN0IDIgZ3JvdXBzDQoNCg0KYGBge3J9DQp3YWxtYXJ0X3NhbGVzX3dlZWtseSAlPiUgDQogIGdyb3VwX2J5KGlkKSAlPiUgDQogIGZpbHRlcihncm91cF9pbmRpY2VzKCkgJWluJSAxOjIpICU+JSANCiAgcGxvdF9zZWFzb25hbF9kaWFnbm9zdGljcyhEYXRlLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIFdlZWtseV9TYWxlcykNCmBgYA0KDQpgYGB7cn0NCmJpa2Vfc2hhcmluZ19kYWlseSAlPiUgDQogIHBsb3Rfc2Vhc29uYWxfZGlhZ25vc3RpY3MoZHRlZGF5LA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIGNudCwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAuZmVhdHVyZV9zZXQgPSAid2RheS5sYmwiKQ0KYGBgDQoNCg0KYGBge3J9DQpiaWtlX3NoYXJpbmdfZGFpbHkgJT4lIA0KICBwbG90X3NlYXNvbmFsX2RpYWdub3N0aWNzKGR0ZWRheSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICBjbnQsDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgLmZlYXR1cmVfc2V0ID0gIndkYXkubGJsIiwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAuZ2VvbSA9IGMoInZpb2xpbiIpDQogICkNCmBgYA0KDQoNCmBgYHtyfQ0Kd2FsbWFydF9zYWxlc193ZWVrbHkgJT4lIA0KICBncm91cF9ieShpZCkgJT4lIA0KICBmaWx0ZXIoZ3JvdXBfaW5kaWNlcygpICVpbiUgMToyKSAlPiUgDQogIHBsb3Rfc2Vhc29uYWxfZGlhZ25vc3RpY3MoRGF0ZSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICBXZWVrbHlfU2FsZXMsDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgLmZlYXR1cmVfc2V0ID0gIndkYXkubGJsIikNCmBgYA0KDQpgYGB7cn0NCndhbG1hcnRfc2FsZXNfd2Vla2x5ICU+JSANCiAgZ3JvdXBfYnkoaWQpICU+JSANCiAgZmlsdGVyKGdyb3VwX2luZGljZXMoKSAlaW4lIDEpICU+JSANCiAgcGxvdF9zZWFzb25hbF9kaWFnbm9zdGljcyhEYXRlLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIFdlZWtseV9TYWxlcywNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAuZmVhdHVyZV9zZXQgPSAid2VlayIpDQpgYGANCg0KDQpgYGB7cn0NCndhbG1hcnRfc2FsZXNfd2Vla2x5ICU+JSANCiAgZ3JvdXBfYnkoaWQpICU+JSANCiAgZmlsdGVyKGdyb3VwX2luZGljZXMoKSAlaW4lIDE6MikgJT4lIA0KICBwbG90X3NlYXNvbmFsX2RpYWdub3N0aWNzKERhdGUsDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgV2Vla2x5X1NhbGVzLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIC5mZWF0dXJlX3NldCA9ICJ3ZWVrIikNCmBgYA0KDQoNCg0KYGBge3J9DQp3YWxtYXJ0X3NhbGVzX3dlZWtseSAlPiUgDQogIGdyb3VwX2J5KGlkKSAlPiUgDQogIGZpbHRlcihncm91cF9pbmRpY2VzKCkgJWluJSAxOjIpICU+JSANCiAgcGxvdF9zZWFzb25hbF9kaWFnbm9zdGljcyhEYXRlLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIFdlZWtseV9TYWxlcywNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAuZmVhdHVyZV9zZXQgPSAibW9udGgubGJsIikNCmBgYA0KDQoNCmBgYHtyfQ0Kd2FsbWFydF9zYWxlc193ZWVrbHkgJT4lIA0KICBncm91cF9ieShpZCkgJT4lIA0KICBmaWx0ZXIoZ3JvdXBfaW5kaWNlcygpICVpbiUgMToyKSAlPiUgDQogIHBsb3Rfc2Vhc29uYWxfZGlhZ25vc3RpY3MoRGF0ZSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICBXZWVrbHlfU2FsZXMsDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgLmZlYXR1cmVfc2V0ID0gImhvdXIiKQ0KYGBgDQoNCmBgYHtyfQ0Kd2FsbWFydF9zYWxlc193ZWVrbHkgJT4lIA0KICBncm91cF9ieShpZCkgJT4lIA0KICBmaWx0ZXIoZ3JvdXBfaW5kaWNlcygpICVpbiUgMSkgJT4lIA0KICBwbG90X3NlYXNvbmFsX2RpYWdub3N0aWNzKERhdGUsDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgV2Vla2x5X1NhbGVzLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIC5mZWF0dXJlX3NldCA9ICJob3VyIikNCmBgYA0KDQpgYGB7cn0NCmJpa2Vfc2hhcmluZ19kYWlseSAlPiUgDQogIHBsb3Rfc2Vhc29uYWxfZGlhZ25vc3RpY3MoZHRlZGF5LA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIGNudCwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAuZmVhdHVyZV9zZXQgPSAiaG91ciIpDQpgYGANCg0KTG9va3MgbGlrZSB3ZSBkb24ndCBoYXZlIGhvdXIgd2lzZSBkYXRhIGluIG91ciBkYXRhIGZyYW1lDQoNCg0KLS0tDQoNCiMjIFRpbWUgU2lnbmF0dXJlDQoNCmBgYHtyfQ0KbGlicmFyeSh3b3JrZmxvd3MpDQpsaWJyYXJ5KHBhcnNuaXApDQpsaWJyYXJ5KHJlY2lwZXMpDQpsaWJyYXJ5KHRpZHlxdWFudCkNCmBgYA0KDQoNCmBgYHtyfQ0KYmlrZXNfdGJsIDwtIGJpa2Vfc2hhcmluZ19kYWlseSAlPiUgDQogIHNlbGVjdChkdGVkYXksIGNudCkgJT4lIA0KICByZW5hbWUoZGF0ZSA9IGR0ZWRheSwNCiAgICAgICAgIHZhbHVlID0gY250KQ0KDQpzdHIoYmlrZXNfdGJsKQ0KYGBgDQoNCmBgYHtyfQ0KaGVhZChiaWtlc190YmwpDQpgYGANCg0KdW5kZXJzdGFuZGluZyBzcGxpdHRpbmcgb2YgZGF0YSB2aXN1YWxseQ0KDQpgYGB7cn0NCmJpa2VzX3RibCAlPiUgDQogIGdncGxvdChhZXMoeCA9IGRhdGUsIHkgPSB2YWx1ZSkpICsNCiAgZ2VvbV9yZWN0KHhtaW4gPSBhcy5udW1lcmljKHltZCgiMjAxMi0wNy0wMSIpKSwNCiAgICAgICAgICAgIHhtYXggPSBhcy5udW1lcmljKHltZCgiMjAxMy0wMS0wMSIpKSwNCiAgICAgICAgICAgIHltaW4gPSAwLCB5bWF4ID0gMTAwMDAsDQogICAgICAgICAgICBmaWxsID0gcGFsZXR0ZV9saWdodCgpW1s0XV0sIGFscGhhID0gMC4wMQ0KICAgICAgICAgICAgKSArDQogIGFubm90YXRlKCJ0ZXh0IiwgeCA9IHltZCgiMjAxMS0xMC0wMSIpLCB5ID0gNzgwMCwNCiAgICAgICAgICAgY29sb3IgPSBwYWxldHRlX2xpZ2h0KClbWzFdXSwgbGFiZWwgPSAiVHJhaW4gUmVnaW9uIikgKw0KICBhbm5vdGF0ZSgidGV4dCIsIHggPSB5bWQoIjIwMTItMTAtMDEiKSwgeSA9IDE1NTAsDQogICAgICAgICAgIGNvbG9yID0gcGFsZXR0ZV9saWdodCgpW1sxXV0sIGxhYmVsID0gIlRlc3QgUmVnaW9uIikgKw0KICBnZW9tX3BvaW50KGFscGhhID0gMC41LCBjb2xvciA9IHBhbGV0dGVfbGlnaHQoKVtbMV1dKSArDQogIGxhYnModGl0bGUgPSAiQmlrZXMgc2hhcmluZyBkYXRhc2V0IikgKw0KICB0aGVtZV90cSgpDQpgYGANCg0KIyMjIHRyYWluIHRlc3Qgc3BsaXQNCg0KYGBge3J9DQp0cmFpbl90YmwgPC0gYmlrZXNfdGJsICU+JSBmaWx0ZXIoZGF0ZSA8IHltZCgiMjAxMi0wNy0wMSIpKQ0KdGVzdF90YmwgPC0gYmlrZXNfdGJsICU+JSBmaWx0ZXIoZGF0ZSA+PSB5bWQoIjIwMTItMDctMDEiKSkNCmBgYA0KDQoNCmBgYHtyfQ0KZGltKHRyYWluX3RibCkNCmRpbSh0ZXN0X3RibCkNCmBgYA0KDQoNCiMjIyBSZWNpcGUNCg0KYGBge3J9DQpyZWNpcGVfc3BlY190cyA8LSByZWNpcGUodmFsdWUgfiAuLA0KICAgICAgICAgICAgICAgICAgICAgICAgIGRhdGEgPSB0cmFpbl90YmwpICU+JSANCiAgICAgICAgICAgICAgICAgIHN0ZXBfdGltZXNlcmllc19zaWduYXR1cmUoZGF0ZSkNCg0KcmVjaXBlX3NwZWNfdHMNCmBgYA0KDQoNCmBgYHtyfQ0KYmFrZWQgPC0gYmFrZShwcmVwKHJlY2lwZV9zcGVjX3RzKSwgbmV3X2RhdGEgPSB0cmFpbl90YmwpDQoNCmhlYWQoYmFrZWQpDQpgYGANCg0KDQpgYGB7cn0NCnN0cihiYWtlZCkNCmBgYA0KDQpgYGB7cn0NCnJlY2lwZV9zcGVjX2ZpbmFsIDwtIHJlY2lwZV9zcGVjX3RzICU+JSANCiAgICAgICAgICAgICAgICAgICAgICAjc3RlcF9ybShkYXRlKSAgIyBrZWVwaW5nIHRoaXMgY29tbWVudGVkIGFzIGl0IGNyZWF0ZXMgcHJvYmxlbSBpbiB1c2Ugc29tZSBhbGdvcml0aG0NCiAgICAgICAgICAgICAgICAgICAgICBzdGVwX3JtKGNvbnRhaW5zKCJpc28iKSwgDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBjb250YWlucygibWludXRlIiksDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBjb250YWlucygiaG91ciIpLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgY29udGFpbnMoImFtLnBtIiksDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBjb250YWlucygieHRzIikNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICkgJT4lIA0KICAgICAgICAgICAgICAgICAgICAgIHN0ZXBfbm9ybWFsaXplKGNvbnRhaW5zKCJpbmRleC5udW0iKSwgZGF0ZV95ZWFyKSAlPiUgDQogICAgICAgICAgICAgICAgICAgICAgc3RlcF9kdW1teShjb250YWlucygibGJsIiksIG9uZV9ob3QgPSBUUlVFKQ0KDQpyZWNpcGVfc3BlY19maW5hbA0KYGBgDQoNCmBgYHtyfQ0KYmFrZWRfZmluYWwgPC0gYmFrZShwcmVwKHJlY2lwZV9zcGVjX2ZpbmFsKSwgbmV3X2RhdGEgPSB0cmFpbl90YmwpDQoNCmJha2VkX2ZpbmFsICU+JSBoZWFkKCkNCmBgYA0KDQpgYGB7cn0NCnN0cihiYWtlZF9maW5hbCkNCmBgYA0KDQojIyMgTW9kZWwgU3BlY3MNCg0KYGBge3J9DQptb2RlbF9zcGVjX2dsbW5ldCA8LSBsaW5lYXJfcmVnKG1vZGUgPSAicmVncmVzc2lvbiIpICU+JSANCiAgICAgICAgICAgICAgICAgICAgICBzZXRfZW5naW5lKCJsbSIpDQpgYGANCg0KIyMjIFdvcmtmbG93DQoNCmBgYHtyfQ0Kd29ya2Zsb3dfZ2xtbmV0IDwtIHdvcmtmbG93KCkgJT4lIA0KICAgICAgICAgICAgICAgICAgICBhZGRfcmVjaXBlKHJlY2lwZV9zcGVjX2ZpbmFsKSAlPiUgDQogICAgICAgICAgICAgICAgICAgIGFkZF9tb2RlbChtb2RlbF9zcGVjX2dsbW5ldCkNCg0Kd29ya2Zsb3dfZ2xtbmV0DQpgYGANCg0KIyMjIFRyYWluaW5nIC8gZml0dGluZw0KDQpgYGB7cn0NCndvcmtmbG93X3RyYWluZWRfZ2xtbmV0IDwtIHdvcmtmbG93X2dsbW5ldCAlPiUgDQogICAgICAgICAgICAgICAgICAgICAgZml0KGRhdGEgPSB0cmFpbl90YmwpDQoNCndvcmtmbG93X3RyYWluZWRfZ2xtbmV0DQpgYGANCg0KIyMjIFRlc3QgLyBWYWxpZGF0aW9uDQoNCmBgYHtyfQ0KcHJlZGljdGlvbl9nbG1uZXRfdGJsIDwtIHdvcmtmbG93X3RyYWluZWRfZ2xtbmV0ICU+JSANCiAgcHJlZGljdCh0ZXN0X3RibCkgJT4lIA0KICBiaW5kX2NvbHModGVzdF90YmwpDQoNCnByZWRpY3Rpb25fZ2xtbmV0X3RibA0KYGBgDQoNCg0KYGBge3J9DQpiaWtlc190YmwgJT4lIA0KICBnZ3Bsb3QoYWVzKHggPSBkYXRlLCB5ID0gdmFsdWUpKSArDQogIGdlb21fcmVjdCh4bWluID0gYXMubnVtZXJpYyh5bWQoIjIwMTItMDctMDEiKSksDQogICAgICAgICAgICB4bWF4ID0gYXMubnVtZXJpYyh5bWQoIjIwMTMtMDEtMDEiKSksDQogICAgICAgICAgICB5bWluID0gMCwgeW1heCA9IDEwMDAwLA0KICAgICAgICAgICAgZmlsbCA9IHBhbGV0dGVfbGlnaHQoKVtbNF1dLCBhbHBoYSA9IDAuMDENCiAgICAgICAgICAgICkgKw0KICBhbm5vdGF0ZSgidGV4dCIsIHggPSB5bWQoIjIwMTEtMTAtMDEiKSwgeSA9IDc4MDAsDQogICAgICAgICAgIGNvbG9yID0gcGFsZXR0ZV9saWdodCgpW1sxXV0sIGxhYmVsID0gIlRyYWluIFJlZ2lvbiIpICsNCiAgYW5ub3RhdGUoInRleHQiLCB4ID0geW1kKCIyMDEyLTEwLTAxIiksIHkgPSAxNTUwLA0KICAgICAgICAgICBjb2xvciA9IHBhbGV0dGVfbGlnaHQoKVtbMV1dLCBsYWJlbCA9ICJUZXN0IFJlZ2lvbiIpICsNCiAgZ2VvbV9wb2ludChhZXMoeCA9IGRhdGUsIHkgPSB2YWx1ZSksDQogICAgICAgICAgICAgYWxwaGEgPSAwLjUsIGNvbG9yID0gcGFsZXR0ZV9saWdodCgpW1sxXV0pICsNCiAgDQogICNBZGQgcHJlZGljdGlvbnMNCiAgZ2VvbV9wb2ludChhZXMoeCA9IGRhdGUsIHkgPSAucHJlZCksIGRhdGEgPSBwcmVkaWN0aW9uX2dsbW5ldF90YmwsDQogICAgICAgICAgICAgYWxwaGEgPSAwLjUsIGNvbG9yID0gcGFsZXR0ZV9saWdodCgpW1syXV0pICsNCiAgDQogIGxhYnModGl0bGUgPSAiQmlrZXMgc2hhcmluZyBkYXRhc2V0IHdpdGggcHJlZGljdGlvbnMiKSArDQogIHRoZW1lX3RxKCkNCmBgYA0KDQojIyMgVmFsaWRhdGlvbiBBY2N1cmFjeQ0KDQpgYGB7cn0NCmxpYnJhcnkoeWFyZHN0aWNrKQ0KYGBgDQoNCg0KYGBge3J9DQpwcmVkaWN0aW9uX2dsbW5ldF90YmwgJT4lIA0KICBtZXRyaWNzKHZhbHVlLCAucHJlZCkNCmBgYA0KDQoNCmBgYHtyfQ0KcHJlZGljdGlvbl9nbG1uZXRfdGJsICU+JSANCiAgZ2dwbG90KGFlcyh4ID0gZGF0ZSwgeSA9IHZhbHVlIC0gLnByZWQpKSArDQogIGdlb21faGxpbmUoeWludGVyY2VwdCA9IDAsIGNvbG9yID0gInJlZCIpICsNCiAgZ2VvbV9wb2ludChjb2xvciA9IHBhbGV0dGVfbGlnaHQoKVtbMV1dLCBhbHBoYSA9IDAuNSkgKw0KICBnZW9tX3Ntb290aCgpICsNCiAgdGhlbWVfdHEoKSArDQogIGxhYnModGl0bGUgPSAiR0xNIE1vZGVsIHJlc2lkdWFscyBvbiB0ZXN0IHNldCIpICsNCiAgc2NhbGVfeV9jb250aW51b3VzKGxpbWl0cyA9IGMoLTUwMDAsIDUwMDApKQ0KICANCmBgYA0KDQojIyMgRm9yZWNhc3QNCg0KYGBge3J9DQppZHggPC0gYmlrZXNfdGJsICU+JSB0a19pbmRleCgpDQoNCmhlYWQoaWR4KQ0KYGBgDQoNCmBgYHtyfQ0KYmlrZXNfc3VtbWFyeSA8LSBpZHggJT4lIHRrX2dldF90aW1lc2VyaWVzX3N1bW1hcnkoKQ0KDQpiaWtlc19zdW1tYXJ5WzE6Nl0NCmBgYA0KDQpgYGB7cn0NCmJpa2VzX3N1bW1hcnlbNzoxMl0NCmBgYA0KDQoNCmBgYHtyfQ0KaWR4X2Z1dHVyZSA8LSBpZHggJT4lIHRrX21ha2VfZnV0dXJlX3RpbWVzZXJpZXMobGVuZ3RoX291dCA9IDIwMCkNCg0KaGVhZChpZHhfZnV0dXJlKQ0KYGBgDQoNCmBgYHtyfQ0KZnV0dXJlX3RibCA8LSB0aWJibGUoZGF0ZSA9IGlkeF9mdXR1cmUpDQoNCmZ1dHVyZV90YmwNCmBgYA0KDQoNCmBgYHtyfQ0KZnV0dXJlX3ByZWRpY3Rpb25zX3RibCA8LSB3b3JrZmxvd190cmFpbmVkX2dsbW5ldCAlPiUgDQogIGZpdChkYXRhID0gYmlrZXNfdGJsKSAlPiUgDQogIHByZWRpY3QoZnV0dXJlX3RibCkgJT4lIA0KICBiaW5kX2NvbHMoZnV0dXJlX3RibCkNCg0KaGVhZChmdXR1cmVfcHJlZGljdGlvbnNfdGJsKQ0KYGBgDQoNCg0KYGBge3J9DQpiaWtlc190YmwgJT4lIA0KICBnZ3Bsb3QoYWVzKHggPSBkYXRlLCB5ID0gdmFsdWUpKSArDQogIGdlb21fcmVjdCh4bWluID0gYXMubnVtZXJpYyh5bWQoIjIwMTItMDctMDEiKSksDQogICAgICAgICAgICB4bWF4ID0gYXMubnVtZXJpYyh5bWQoIjIwMTMtMDEtMDEiKSksDQogICAgICAgICAgICB5bWluID0gMCwgeW1heCA9IDEwMDAwLA0KICAgICAgICAgICAgZmlsbCA9IHBhbGV0dGVfbGlnaHQoKVtbNF1dLCBhbHBoYSA9IDAuMDENCiAgICAgICAgICAgICkgKw0KICBnZW9tX3JlY3QoeG1pbiA9IGFzLm51bWVyaWMoeW1kKCIyMDEzLTAxLTAxIikpLA0KICAgICAgICAgICAgeG1heCA9IGFzLm51bWVyaWMoeW1kKCIyMDEzLTA3LTAxIikpLA0KICAgICAgICAgICAgeW1pbiA9IDAsIHltYXggPSAxMDAwMCwNCiAgICAgICAgICAgIGZpbGwgPSBwYWxldHRlX2xpZ2h0KClbWzVdXSwgYWxwaGEgPSAwLjAxDQogICAgICAgICAgICApICsNCiAgYW5ub3RhdGUoInRleHQiLCB4ID0geW1kKCIyMDExLTEwLTAxIiksIHkgPSA3ODAwLA0KICAgICAgICAgICBjb2xvciA9IHBhbGV0dGVfbGlnaHQoKVtbMV1dLCBsYWJlbCA9ICJUcmFpbiBSZWdpb24iKSArDQogIGFubm90YXRlKCJ0ZXh0IiwgeCA9IHltZCgiMjAxMi0xMC0wMSIpLCB5ID0gMTU1MCwNCiAgICAgICAgICAgY29sb3IgPSBwYWxldHRlX2xpZ2h0KClbWzFdXSwgbGFiZWwgPSAiVGVzdCBSZWdpb24iKSArDQogIGFubm90YXRlKCJ0ZXh0IiwgeCA9IHltZCgiMjAxMy0wNC0wMSIpLCB5ID0gMTU1MCwNCiAgICAgICAgICAgY29sb3IgPSBwYWxldHRlX2xpZ2h0KClbWzFdXSwgbGFiZWwgPSAiRm9yZWNhc3QgUmVnaW9uIikgKw0KICBnZW9tX3BvaW50KCNhZXMoeCA9IGRhdGUsIHkgPSB2YWx1ZSksDQogICAgICAgICAgICAgYWxwaGEgPSAwLjUsIGNvbG9yID0gcGFsZXR0ZV9saWdodCgpW1sxXV0pICsNCiAgDQogICNBZGQgcHJlZGljdGlvbnMNCiAgZ2VvbV9wb2ludChhZXMoeCA9IGRhdGUsIHkgPSAucHJlZCksIGRhdGEgPSBwcmVkaWN0aW9uX2dsbW5ldF90YmwsDQogICAgICAgICAgICAgYWxwaGEgPSAwLjUsIGNvbG9yID0gcGFsZXR0ZV9saWdodCgpW1syXV0pICsNCiAgZ2VvbV9wb2ludChhZXMoeCA9IGRhdGUsIHkgPSAucHJlZCksIGRhdGEgPSBmdXR1cmVfcHJlZGljdGlvbnNfdGJsLA0KICAgICAgICAgICAgIGFscGhhID0gMC41LCBjb2xvciA9IHBhbGV0dGVfbGlnaHQoKVtbMl1dKSArDQogIA0KICBnZW9tX3Ntb290aChhZXMoeCA9IGRhdGUsIHkgPSAucHJlZCksIGRhdGEgPSBmdXR1cmVfcHJlZGljdGlvbnNfdGJsLA0KICAgICAgICAgICAgICBtZXRob2QgPSAibG9lc3MiKSArDQogIA0KICBsYWJzKHRpdGxlID0gIkJpa2VzIHNoYXJpbmcgZGF0YXNldCB3aXRoIHByZWRpY3Rpb25zIikgKw0KICB0aGVtZV90cSgpDQpgYGANCg0KIyMjIEZvcmVjYXN0IEVycm9yDQoNCmBgYHtyfQ0KdGVzdF9yZXNpZF9zZCA8LSBwcmVkaWN0aW9uX2dsbW5ldF90YmwgJT4lIA0KICBzdW1tYXJpc2Uoc3RkZXYgPSBzZCh2YWx1ZSAtIC5wcmVkKSkNCg0KaGVhZCh0ZXN0X3Jlc2lkX3NkKQ0KYGBgDQoNCg0KYGBge3J9DQpmdXR1cmVfcHJlZGljdGlvbnNfdGJsIDwtIGZ1dHVyZV9wcmVkaWN0aW9uc190YmwgJT4lIA0KICBtdXRhdGUobG8uOTUgPSAucHJlZCAtIDEuOTYgKiB0ZXN0X3Jlc2lkX3NkJHN0ZGV2LA0KICAgICAgICAgbG8uODAgPSAucHJlZCAtIDEuMjggKiB0ZXN0X3Jlc2lkX3NkJHN0ZGV2LA0KICAgICAgICAgaGkuODAgPSAucHJlZCArIDEuMjggKiB0ZXN0X3Jlc2lkX3NkJHN0ZGV2LA0KICAgICAgICAgaGkuOTUgPSAucHJlZCArIDEuOTYgKiB0ZXN0X3Jlc2lkX3NkJHN0ZGV2DQogICAgICAgICApDQoNCmhlYWQoZnV0dXJlX3ByZWRpY3Rpb25zX3RibCkNCmBgYA0KDQoNCmBgYHtyfQ0KYmlrZXNfdGJsICU+JSANCiAgZ2dwbG90KGFlcyh4ID0gZGF0ZSwgeSA9IHZhbHVlKSkgKw0KICBnZW9tX3BvaW50KGFscGhhID0gMC41LCBjb2xvciA9IHBhbGV0dGVfbGlnaHQoKVtbMV1dKSArDQogIGdlb21fcmliYm9uKGFlcyh5ID0gLnByZWQsIHltaW4gPSBsby45NSwgeW1heCA9IGhpLjk1KSwgDQogICAgICAgICAgICAgIGRhdGEgPSBmdXR1cmVfcHJlZGljdGlvbnNfdGJsLA0KICAgICAgICAgICAgICBmaWxsID0gIiMwNTBCRkYiLCBjb2xvciA9IE5BLCBzaXplID0gMCkgKw0KICBnZW9tX3JpYmJvbihhZXMoeSA9IC5wcmVkLCB5bWluID0gbG8uODAsIHltYXggPSBoaS44MCwgZmlsbCA9IGtleSksIA0KICAgICAgICAgICAgICBkYXRhID0gZnV0dXJlX3ByZWRpY3Rpb25zX3RibCwNCiAgICAgICAgICAgICAgZmlsbCA9ICIjNTk2REQ1IiwgY29sb3IgPSBOQSwgc2l6ZSA9IDAsIGFscGhhID0gMC44KSArDQogIGdlb21fcG9pbnQoYWVzKHggPSBkYXRlLCB5ID0gLnByZWQpLCBkYXRhID0gZnV0dXJlX3ByZWRpY3Rpb25zX3RibCwNCiAgICAgICAgICAgICBhbHBoYSA9IDAuNSwgY29sb3IgPSBwYWxldHRlX2xpZ2h0KClbWzJdXSkgKw0KICBnZW9tX3Ntb290aChhZXMoeCA9IGRhdGUsIHkgPSAucHJlZCksIGRhdGEgPSBmdXR1cmVfcHJlZGljdGlvbnNfdGJsLA0KICAgICAgICAgICAgICBtZXRob2QgPSAibG9lc3MiLCBjb2xvciA9ICJ3aGl0ZSIpICsNCiAgbGFicyh0aXRsZSA9ICJCaWtlcyBTaGFpbmcgRGF0YXNldCIpICsNCiAgdGhlbWVfdHEoKQ0KYGBgDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQo=